home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / INTERP.C < prev    next >
C/C++ Source or Header  |  1992-02-08  |  63KB  |  2,211 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/users/cph/src/microcode/RCS/interp.c,v 9.66 1992/02/08 14:54:07 cph Exp $
  4.  
  5. Copyright (c) 1988-92 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* This file contains the heart of the SCode interpreter. */
  36.  
  37. #define In_Main_Interpreter true
  38. #include "scheme.h"
  39. #include "locks.h"
  40. #include "trap.h"
  41. #include "lookup.h"
  42. #include "winder.h"
  43. #include "history.h"
  44. #include "cmpint.h"
  45. #include "zones.h"
  46. #include "prmcon.h"
  47.  
  48. extern PTR EXFUN (obstack_chunk_alloc, (unsigned int size));
  49. extern void EXFUN (free, (PTR ptr));
  50. #define obstack_chunk_free free
  51. extern void EXFUN (back_out_of_primitive_internal, (void));
  52. extern void EXFUN (preserve_signal_mask, (void));
  53.  
  54. /* In order to make the interpreter tail recursive (i.e.
  55.  * to avoid calling procedures and thus saving unnecessary
  56.  * state information), the main body of the interpreter
  57.  * is coded in a continuation passing style.
  58.  *
  59.  * Basically, this is done by dispatching on the type code
  60.  * for an Scode item.  At each dispatch, some processing
  61.  * is done which may include setting the return address
  62.  * register, saving the current continuation (return address
  63.  * and current expression) and jumping to the start of
  64.  * the interpreter.
  65.  *
  66.  * It may be helpful to think of this program as being what
  67.  * you would get if you wrote the straightforward Scheme
  68.  * interpreter and then converted it into continuation
  69.  * passing style as follows.  At every point where you would
  70.  * call EVAL to handle a sub-form, you put a jump back to
  71.  * Do_Expression.  Now, if there was code after the call to
  72.  * EVAL you first push a "return code" (using Save_Cont) on
  73.  * the stack and move the code that used to be after the
  74.  * call down into the part of this file after the tag
  75.  * Pop_Return.
  76.  *
  77.  * Notice that because of the caller saves convention used
  78.  * here, all of the registers which are of interest have
  79.  * been SAVEd on the racks by the time interpretation arrives
  80.  * at Do_Expression (the top of EVAL).
  81.  *
  82.  * For notes on error handling and interrupts, see the file
  83.  * utils.c.
  84.  *
  85.  * This file is divided into two parts. The first
  86.  * corresponds is called the EVAL dispatch, and is ordered
  87.  * alphabetically by the SCode item handled.  The second,
  88.  * called the return dispatch, begins at Pop_Return and is
  89.  * ordered alphabetically by return code name.
  90.  */
  91.  
  92. #define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val)    \
  93. {                                    \
  94.   SCHEME_OBJECT temp;                            \
  95.                                     \
  96.   temp = (Contents_of_Val);                        \
  97.   Store_Return(Return_Code);                        \
  98.   Save_Cont();                                \
  99.   Store_Return(RC_RESTORE_VALUE);                    \
  100.   Store_Expression(temp);                        \
  101.   Save_Cont();                                \
  102. }
  103.  
  104. #define Interrupt(Masked_Code)                        \
  105. {                                    \
  106.   Export_Registers();                            \
  107.   Setup_Interrupt(Masked_Code);                        \
  108.   Import_Registers();                            \
  109.   goto Perform_Application;                        \
  110. }
  111.  
  112. #define Immediate_GC(N)                            \
  113. {                                    \
  114.   Request_GC(N);                            \
  115.   Interrupt(PENDING_INTERRUPTS());                    \
  116. }
  117.  
  118. #define Eval_GC_Check(Amount)                        \
  119. if (GC_Check(Amount))                            \
  120. {                                    \
  121.   Prepare_Eval_Repeat();                        \
  122.   Immediate_GC(Amount);                            \
  123. }
  124.  
  125. #define RESULT_OF_PURIFY(success)                    \
  126. {                                    \
  127.   SCHEME_OBJECT words_free;                        \
  128.                                     \
  129.   words_free = (LONG_TO_UNSIGNED_FIXNUM (MemTop - Free));        \
  130.   Val = (MAKE_POINTER_OBJECT (TC_LIST, Free));                \
  131.   (*Free++) = (success);                        \
  132.   (*Free++) = words_free;                        \
  133. }
  134.  
  135. #define Prepare_Eval_Repeat()                        \
  136. {                                    \
  137.  Will_Push(CONTINUATION_SIZE+1);                    \
  138.   STACK_PUSH (Fetch_Env());                        \
  139.   Store_Return(RC_EVAL_ERROR);                        \
  140.   Save_Cont();                                \
  141.  Pushed();                                \
  142. }
  143.  
  144. #define Eval_Error(Err)                            \
  145. {                                    \
  146.   Export_Registers();                            \
  147.   Do_Micro_Error(Err, false);                        \
  148.   Import_Registers();                            \
  149.   goto Internal_Apply;                            \
  150. }
  151.  
  152. #define Pop_Return_Error(Err)                        \
  153. {                                    \
  154.   Export_Registers();                            \
  155.   Do_Micro_Error(Err, true);                        \
  156.   Import_Registers();                            \
  157.   goto Internal_Apply;                            \
  158. }
  159.  
  160. #define BACK_OUT_AFTER_PRIMITIVE()                    \
  161. {                                    \
  162.   Export_Registers();                            \
  163.   back_out_of_primitive_internal ();                    \
  164.   Import_Registers();                            \
  165. }
  166.  
  167. #define Reduces_To(Expr)                        \
  168.     { Store_Expression(Expr);                    \
  169.           New_Reduction(Fetch_Expression(), Fetch_Env());        \
  170.           goto Do_Expression;                        \
  171.         }
  172.  
  173. #define Reduces_To_Nth(N)                        \
  174.         Reduces_To(FAST_MEMORY_REF (Fetch_Expression(), (N)))
  175.  
  176. #define Do_Nth_Then(Return_Code, N, Extra)                \
  177.     { Store_Return(Return_Code);                    \
  178.       Save_Cont();                            \
  179.       Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), (N)));    \
  180.       New_Subproblem(Fetch_Expression(), Fetch_Env());        \
  181.           Extra;                            \
  182.       goto Do_Expression;                        \
  183.         }
  184.  
  185. #define Do_Another_Then(Return_Code, N)                    \
  186.     { Store_Return(Return_Code);                    \
  187.           Save_Cont();                            \
  188.       Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), (N)));    \
  189.       Reuse_Subproblem(Fetch_Expression(), Fetch_Env());        \
  190.       goto Do_Expression;                        \
  191.         }
  192.  
  193.                       /***********************/
  194.                       /* Macros for Stepping */
  195.                       /***********************/
  196.  
  197. #define Fetch_Trapper(field)    \
  198.   MEMORY_REF (Get_Fixed_Obj_Slot(Stepper_State), (field))
  199.  
  200. #define Fetch_Eval_Trapper() Fetch_Trapper(HUNK_CXR0)
  201. #define Fetch_Apply_Trapper() Fetch_Trapper(HUNK_CXR1)
  202. #define Fetch_Return_Trapper() Fetch_Trapper(HUNK_CXR2)
  203.  
  204. /* Macros for handling FUTUREs */
  205.  
  206. #ifdef COMPILE_FUTURES
  207.  
  208. /* ARG_TYPE_ERROR handles the error returns from primitives which type check
  209.    their arguments and restarts them or suspends if the argument is a future.
  210.  */
  211.  
  212. #define ARG_TYPE_ERROR(Arg_No, Err_No)                    \
  213. {                                    \
  214.   fast SCHEME_OBJECT *Arg, Orig_Arg;                    \
  215.                                     \
  216.   Arg = &(STACK_REF((Arg_No - 1) + STACK_ENV_FIRST_ARG));        \
  217.   Orig_Arg = *Arg;                            \
  218.                                     \
  219.   if (OBJECT_TYPE (*Arg) != TC_FUTURE)                    \
  220.   {                                    \
  221.     Pop_Return_Error(Err_No);                        \
  222.   }                                    \
  223.                                     \
  224.   while ((OBJECT_TYPE (*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg)))    \
  225.   {                                    \
  226.     if (Future_Is_Keep_Slot(*Arg))                    \
  227.     {                                    \
  228.       Log_Touch_Of_Future(*Arg);                    \
  229.     }                                    \
  230.     *Arg = Future_Value(*Arg);                        \
  231.   }                                    \
  232.   if (OBJECT_TYPE (*Arg) != TC_FUTURE)                    \
  233.   {                                    \
  234.     goto Apply_Non_Trapping;                        \
  235.   }                                    \
  236.                                     \
  237.   TOUCH_SETUP(*Arg);                            \
  238.   *Arg = Orig_Arg;                            \
  239.   goto Apply_Non_Trapping;                        \
  240. }
  241.  
  242. /* Apply_Future_Check is called at apply time to guarantee that certain
  243.    objects (the procedure itself, and its LAMBDA components for user defined
  244.    procedures) are not futures
  245. */
  246.  
  247. #define Apply_Future_Check(Name, Object)                \
  248. {                                    \
  249.   fast SCHEME_OBJECT *Arg, Orig_Answer;                    \
  250.                                     \
  251.   Arg = &(Object);                            \
  252.   Orig_Answer = *Arg;                            \
  253.                                     \
  254.   while (OBJECT_TYPE (*Arg) == TC_FUTURE)                \
  255.   {                                    \
  256.     if (Future_Has_Value(*Arg))                        \
  257.     {                                    \
  258.       if (Future_Is_Keep_Slot(*Arg))                    \
  259.       {                                    \
  260.     Log_Touch_Of_Future(*Arg);                    \
  261.       }                                    \
  262.       *Arg = Future_Value(*Arg);                    \
  263.     }                                    \
  264.     else                                \
  265.     {                                    \
  266.       Prepare_Apply_Interrupt ();                    \
  267.       TOUCH_SETUP (*Arg);                        \
  268.       *Arg = Orig_Answer;                        \
  269.       goto Internal_Apply;                        \
  270.     }                                    \
  271.   }                                    \
  272.   Name = *Arg;                                \
  273. }
  274.  
  275. /* Future handling macros continue on the next page */
  276.  
  277. /* Future handling macros, continued */
  278.  
  279. /* Pop_Return_Val_Check suspends the process if the value calculated by
  280.    a recursive call to EVAL is an undetermined future */
  281.  
  282. #define Pop_Return_Val_Check()                        \
  283. {                                    \
  284.   fast SCHEME_OBJECT Orig_Val = Val;                    \
  285.                                     \
  286.   while (OBJECT_TYPE (Val) == TC_FUTURE)                \
  287.   {                                    \
  288.     if (Future_Has_Value(Val))                        \
  289.     {                                    \
  290.       if (Future_Is_Keep_Slot(Val))                    \
  291.       {                                    \
  292.     Log_Touch_Of_Future(Val);                    \
  293.       }                                    \
  294.       Val = Future_Value(Val);                        \
  295.     }                                    \
  296.     else                                \
  297.     {                                    \
  298.       Save_Cont();                            \
  299.      Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 2));    \
  300.       Store_Return(RC_RESTORE_VALUE);                    \
  301.       Store_Expression(Orig_Val);                    \
  302.       Save_Cont();                            \
  303.       STACK_PUSH (Val);                            \
  304.       STACK_PUSH (Get_Fixed_Obj_Slot(System_Scheduler));        \
  305.       STACK_PUSH (STACK_FRAME_HEADER + 1);                \
  306.      Pushed();                                \
  307.       goto Internal_Apply;                        \
  308.     }                                    \
  309.   }                                    \
  310. }
  311.  
  312. /* This saves stuff unnecessarily in most cases.
  313.    For example, when Which_Way is PRIM_APPLY, Val, Env, Expr,
  314.    and Return_Code are undefined.
  315.  */
  316.  
  317. #define LOG_FUTURES()                            \
  318. {                                    \
  319.   if (Must_Report_References())                        \
  320.   {                                    \
  321.     Save_Cont();                            \
  322.    Will_Push(CONTINUATION_SIZE + 2);                    \
  323.     STACK_PUSH (Val);                            \
  324.     Save_Env();                                \
  325.     Store_Return(RC_REPEAT_DISPATCH);                    \
  326.     Store_Expression(LONG_TO_FIXNUM(CODE_MAP(Which_Way)));        \
  327.     Save_Cont();                            \
  328.    Pushed();                                \
  329.     Call_Future_Logging();                        \
  330.  }                                    \
  331. }
  332.  
  333. #else /* not COMPILE_FUTURES */
  334.  
  335. #define Pop_Return_Val_Check()
  336.  
  337. #define Apply_Future_Check(Name, Object)    Name = (Object)
  338.  
  339. #define ARG_TYPE_ERROR(Arg_No, Err_No)                    \
  340. {                                    \
  341.   Pop_Return_Error(Err_No)                        \
  342. }
  343.  
  344. #define LOG_FUTURES()
  345.  
  346. #endif /* COMPILE_FUTURES */
  347.  
  348. /* Notes on Repeat_Dispatch:
  349.  
  350.    The codes used (values of Which_Way) are divided into two groups:
  351.    Those for which the primitive has already backed out, and those for
  352.    which the back out code has not yet been executed, and is therefore
  353.    executed below.
  354.  
  355.    Under most circumstances the distinction is moot, but if there are
  356.    futures in the system, and future touches must be logged, the code
  357.    must be set up to "interrupt" the dispatch, and proceed it later.
  358.    The primitive back out code must be done before the furure is
  359.    logged, so all of these codes are split into two versions: one set
  360.    before doing the back out, and another afterwards.
  361.  */
  362.  
  363. /* This is assumed to be larger (in absolute value) than any PRIM_<mumble>
  364.    and ERR_<mumble>.
  365.  */
  366. #define PRIM_BIAS_AMOUNT 1000
  367.  
  368. #if (MAX_ERROR >= PRIM_BIAS_AMOUNT)
  369. #include "Inconsistency: errors.h and interp.c"
  370. #endif
  371.  
  372. #define CODE_MAP(code)                            \
  373. ((code < 0) ?                                \
  374.  (code - PRIM_BIAS_AMOUNT) :                        \
  375.  (code + PRIM_BIAS_AMOUNT))
  376.  
  377. #define CODE_UNMAP(code)                        \
  378. ((code < 0) ?                                \
  379.  (code + PRIM_BIAS_AMOUNT) :                        \
  380.  (code - PRIM_BIAS_AMOUNT))
  381.  
  382. #define CODE_MAPPED_P(code)                        \
  383. ((code < (- PRIM_BIAS_AMOUNT)) ||                    \
  384.  (code >= PRIM_BIAS_AMOUNT))
  385.  
  386. #define PROCEED_AFTER_PRIMITIVE()                    \
  387. {                                    \
  388.   (Regs [REGBLOCK_PRIMITIVE]) = SHARP_F;                \
  389.   LOG_FUTURES ();                            \
  390. }
  391.  
  392. /*
  393.   The EVAL/APPLY ying/yang
  394.  */
  395.  
  396. static PTR interpreter_catch_dstack_position;
  397. static jmp_buf interpreter_catch_env;
  398. static int interpreter_throw_argument;
  399.  
  400. void
  401. DEFUN (abort_to_interpreter, (argument), int argument)
  402. {
  403.   interpreter_throw_argument = argument;
  404.   {
  405.     long old_mask = IntEnb;
  406.     IntEnb = 0;
  407.     dstack_set_position (interpreter_catch_dstack_position);
  408.     IntEnb = old_mask;
  409.   }
  410.   obstack_free ((&scratch_obstack), 0);
  411.   obstack_init (&scratch_obstack);
  412.   longjmp (interpreter_catch_env, argument);
  413. }
  414.  
  415. int
  416. DEFUN_VOID (abort_to_interpreter_argument)
  417. {
  418.   return (interpreter_throw_argument);
  419. }
  420.  
  421. void
  422. DEFUN (Interpret, (dumped_p), Boolean dumped_p)
  423. {
  424.   long Which_Way;
  425.   fast SCHEME_OBJECT *Reg_Block, *Reg_Stack_Pointer, *Reg_History;
  426.  
  427.   extern long enter_compiled_expression();
  428.   extern long apply_compiled_procedure();
  429.   extern long return_to_compiled_code();
  430.  
  431.   Reg_Block = &Registers[0];
  432.  
  433.   /* Primitives jump back here for errors, requests to evaluate an
  434.    * expression, apply a function, or handle an interrupt request.  On
  435.    * errors or interrupts they leave their arguments on the stack, the
  436.    * primitive itself in Expression.  The code should do a primitive
  437.    * backout in these cases, but not in others (apply, eval, etc.), since
  438.    * the primitive itself will have left the state of the interpreter ready
  439.    * for operation.
  440.    */
  441.  
  442.   interpreter_catch_dstack_position = dstack_position;
  443.   preserve_signal_mask ();
  444.   Which_Way = (setjmp (interpreter_catch_env));
  445.   Set_Time_Zone (Zone_Working);
  446.   Import_Registers ();
  447.  
  448. Repeat_Dispatch:
  449.   switch (Which_Way)
  450.   {
  451.     case PRIM_APPLY:
  452.       PROCEED_AFTER_PRIMITIVE();
  453.     case CODE_MAP(PRIM_APPLY):
  454.       goto Internal_Apply;
  455.  
  456.     case PRIM_NO_TRAP_APPLY:
  457.       PROCEED_AFTER_PRIMITIVE();
  458.     case CODE_MAP(PRIM_NO_TRAP_APPLY):
  459.       goto Apply_Non_Trapping;
  460.  
  461.     case PRIM_DO_EXPRESSION:
  462.       Val = Fetch_Expression();
  463.       PROCEED_AFTER_PRIMITIVE();
  464.     case CODE_MAP(PRIM_DO_EXPRESSION):
  465.       Reduces_To(Val);
  466.  
  467.     case PRIM_NO_TRAP_EVAL:
  468.       Val = Fetch_Expression();
  469.       PROCEED_AFTER_PRIMITIVE();
  470.     case CODE_MAP(PRIM_NO_TRAP_EVAL):
  471.       New_Reduction(Val, Fetch_Env());
  472.       goto Eval_Non_Trapping;
  473.  
  474.     case 0:            /* first time */
  475.       if (dumped_p)
  476.       {
  477.     goto Pop_Return;
  478.       }
  479.       else
  480.       {
  481.     break;            /* fall into eval */
  482.       }
  483.  
  484.     case PRIM_POP_RETURN:
  485.       PROCEED_AFTER_PRIMITIVE();
  486.     case CODE_MAP(PRIM_POP_RETURN):
  487.       goto Pop_Return;
  488.  
  489.     case PRIM_NO_TRAP_POP_RETURN:
  490.       PROCEED_AFTER_PRIMITIVE();
  491.     case CODE_MAP(PRIM_NO_TRAP_POP_RETURN):
  492.       goto Pop_Return_Non_Trapping;
  493.  
  494.     case PRIM_REENTER:
  495.       BACK_OUT_AFTER_PRIMITIVE();
  496.       LOG_FUTURES();
  497.     case CODE_MAP(PRIM_REENTER):
  498.       goto Perform_Application;
  499.  
  500.     case PRIM_TOUCH:
  501.     {
  502.       SCHEME_OBJECT temp;
  503.  
  504.       temp = Val;
  505.       BACK_OUT_AFTER_PRIMITIVE();
  506.       Val = temp;
  507.       LOG_FUTURES();
  508.     }
  509.     /* fall through */
  510.     case CODE_MAP(PRIM_TOUCH):
  511.       TOUCH_SETUP(Val);
  512.       goto Internal_Apply;
  513.  
  514.     case PRIM_INTERRUPT:
  515.       BACK_OUT_AFTER_PRIMITIVE();
  516.       LOG_FUTURES();
  517.       /* fall through */
  518.     case CODE_MAP(PRIM_INTERRUPT):
  519.       Save_Cont();
  520.       Interrupt(PENDING_INTERRUPTS());
  521.  
  522.     case ERR_ARG_1_WRONG_TYPE:
  523.       BACK_OUT_AFTER_PRIMITIVE();
  524.       LOG_FUTURES();
  525.       /* fall through */
  526.     case CODE_MAP(ERR_ARG_1_WRONG_TYPE):
  527.       ARG_TYPE_ERROR(1, ERR_ARG_1_WRONG_TYPE);
  528.  
  529.     case ERR_ARG_2_WRONG_TYPE:
  530.       BACK_OUT_AFTER_PRIMITIVE();
  531.       LOG_FUTURES();
  532.       /* fall through */
  533.     case CODE_MAP(ERR_ARG_2_WRONG_TYPE):
  534.       ARG_TYPE_ERROR(2, ERR_ARG_2_WRONG_TYPE);
  535.  
  536.     case ERR_ARG_3_WRONG_TYPE:
  537.       BACK_OUT_AFTER_PRIMITIVE();
  538.       LOG_FUTURES();
  539.       /* fall through */
  540.     case CODE_MAP(ERR_ARG_3_WRONG_TYPE):
  541.       ARG_TYPE_ERROR(3, ERR_ARG_3_WRONG_TYPE);
  542.  
  543.     default:
  544.     {
  545.       if (!CODE_MAPPED_P(Which_Way))
  546.       {
  547.     BACK_OUT_AFTER_PRIMITIVE();
  548.     LOG_FUTURES();
  549.       }
  550.       else
  551.       {
  552.     Which_Way = CODE_UNMAP(Which_Way);
  553.       }
  554.       Pop_Return_Error(Which_Way);
  555.     }
  556.   }
  557.  
  558. Do_Expression:
  559.  
  560.   if (Eval_Debug)
  561.   { Print_Expression(Fetch_Expression(), "Eval, expression");
  562.     printf ("\n");
  563.   }
  564.  
  565. /* The expression register has an Scode item in it which
  566.  * should be evaluated and the result left in Val.
  567.  *
  568.  * A "break" after the code for any operation indicates that
  569.  * all processing for this operation has been completed, and
  570.  * the next step will be to pop a return code off the stack
  571.  * and proceed at Pop_Return.  This is sometimes called
  572.  * "executing the continuation" since the return code can be
  573.  * considered the continuation to be performed after the
  574.  * operation.
  575.  *
  576.  * An operation can terminate with a Reduces_To or
  577.  * Reduces_To_Nth macro.  This indicates that the  value of
  578.  * the current Scode item is the value returned when the
  579.  * new expression is evaluated.  Therefore no new
  580.  * continuation is created and processing continues at
  581.  * Do_Expression with the new expression in the expression
  582.  * register.
  583.  *
  584.  * Finally, an operation can terminate with a Do_Nth_Then
  585.  * macro.  This indicates that another expression must be
  586.  * evaluated and them some additional processing will be
  587.  * performed before the value of this S-Code item available.
  588.  * Thus a new continuation is created and placed on the
  589.  * stack (using Save_Cont), the new expression is placed in
  590.  * the Expression register, and processing continues at
  591.  * Do_Expression.
  592.  */
  593.  
  594. /* Handling of Eval Trapping.
  595.  
  596.    If we are handling traps and there is an Eval Trap set,
  597.    turn off all trapping and then go to Internal_Apply to call the
  598.    user supplied eval hook with the expression to be evaluated and the
  599.    environment. */
  600.  
  601.   if (Microcode_Does_Stepping &&
  602.       Trapping &&
  603.       (! WITHIN_CRITICAL_SECTION_P()) &&
  604.       ((Fetch_Eval_Trapper ()) != SHARP_F))
  605.   {
  606.     Stop_Trapping ();
  607.    Will_Push (4);
  608.     STACK_PUSH (Fetch_Env ());
  609.     STACK_PUSH (Fetch_Expression ());
  610.     STACK_PUSH (Fetch_Eval_Trapper ());
  611.     STACK_PUSH (STACK_FRAME_HEADER + 2);
  612.    Pushed ();
  613.     goto Apply_Non_Trapping;
  614.   }
  615.  
  616. Eval_Non_Trapping:
  617.   Eval_Ucode_Hook();
  618.   switch (OBJECT_TYPE (Fetch_Expression()))
  619.   {
  620.     default:
  621. #if FALSE
  622.       Eval_Error(ERR_UNDEFINED_USER_TYPE);
  623. #else
  624.       /* fall through to self evaluating. */
  625. #endif
  626.  
  627.     case TC_BIG_FIXNUM:         /* The self evaluating items */
  628.     case TC_BIG_FLONUM:
  629.     case TC_CHARACTER_STRING:
  630.     case TC_CHARACTER:
  631.     case TC_COMPILED_CODE_BLOCK:
  632.     case TC_COMPLEX:
  633.     case TC_CONTROL_POINT:
  634.     case TC_DELAYED:
  635.     case TC_ENTITY:
  636.     case TC_ENVIRONMENT:
  637.     case TC_EXTENDED_PROCEDURE:
  638.     case TC_FIXNUM:
  639.     case TC_HUNK3_A:
  640.     case TC_HUNK3_B:
  641.     case TC_INTERNED_SYMBOL:
  642.     case TC_LIST:
  643.     case TC_NON_MARKED_VECTOR:
  644.     case TC_NULL:
  645.     case TC_PRIMITIVE:
  646.     case TC_PROCEDURE:
  647.     case TC_QUAD:
  648.     case TC_RATNUM:
  649.     case TC_REFERENCE_TRAP:
  650.     case TC_RETURN_CODE:
  651.     case TC_UNINTERNED_SYMBOL:
  652.     case TC_TRUE:
  653.     case TC_VECTOR:
  654.     case TC_VECTOR_16B:
  655.     case TC_VECTOR_1B:
  656.       Val = Fetch_Expression();
  657.       break;
  658.  
  659.     case TC_ACCESS:
  660.      Will_Push(CONTINUATION_SIZE);
  661.       Do_Nth_Then(RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT, Pushed());
  662.  
  663.     case TC_ASSIGNMENT:
  664.      Will_Push(CONTINUATION_SIZE + 1);
  665.       Save_Env();
  666.       Do_Nth_Then(RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE, Pushed());
  667.  
  668.     case TC_BROKEN_HEART:
  669.       Export_Registers();
  670.       Microcode_Termination(TERM_BROKEN_HEART);
  671.  
  672. /* Interpret() continues on the next page */
  673.  
  674. /* Interpret(), continued */
  675.  
  676.     case TC_COMBINATION:
  677.       {
  678.     long Array_Length;
  679.  
  680.     Array_Length = (VECTOR_LENGTH (Fetch_Expression()) - 1);
  681. #ifdef USE_STACKLETS
  682.     /* Save_Env, Finger */
  683.         Eval_GC_Check(New_Stacklet_Size(Array_Length + 1 + 1 + CONTINUATION_SIZE));
  684. #endif /* USE_STACKLETS */
  685.        Will_Push(Array_Length + 1 + 1 + CONTINUATION_SIZE);
  686.     Stack_Pointer = (STACK_LOC (- Array_Length));
  687.         STACK_PUSH (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Array_Length));
  688.     /* The finger: last argument number */
  689.        Pushed();
  690.         if (Array_Length == 0)
  691.     {
  692.       STACK_PUSH (STACK_FRAME_HEADER);   /* Frame size */
  693.           Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {});
  694.     }
  695.     Save_Env();
  696.     Do_Nth_Then(RC_COMB_SAVE_VALUE, Array_Length+1, {});
  697.       }
  698.  
  699.     case TC_COMBINATION_1:
  700.      Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
  701.       Save_Env();
  702.       Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1, {});
  703.  
  704.     case TC_COMBINATION_2:
  705.      Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
  706.       Save_Env();
  707.       Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {});
  708.  
  709.     case TC_COMMENT:
  710.       Reduces_To_Nth(COMMENT_EXPRESSION);
  711.  
  712.     case TC_CONDITIONAL:
  713.      Will_Push(CONTINUATION_SIZE + 1);
  714.       Save_Env();
  715.       Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE, Pushed());
  716.  
  717.     case TC_COMPILED_ENTRY:
  718.       {
  719.     SCHEME_OBJECT compiled_expression;
  720.  
  721.     compiled_expression = (Fetch_Expression ());
  722.     execute_compiled_setup();
  723.     Store_Expression (compiled_expression);
  724.     Export_Registers();
  725.     Which_Way = enter_compiled_expression();
  726.     goto return_from_compiled_code;
  727.       }
  728.  
  729. /* Interpret() continues on the next page */
  730.  
  731. /* Interpret(), continued */
  732.  
  733.     case TC_DEFINITION:
  734.      Will_Push(CONTINUATION_SIZE + 1);
  735.       Save_Env();
  736.       Do_Nth_Then(RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE, Pushed());
  737.  
  738.     case TC_DELAY:
  739.       /* Deliberately omitted: Eval_GC_Check(2); */
  740.       Val = MAKE_POINTER_OBJECT (TC_DELAYED, Free);
  741.       Free[THUNK_ENVIRONMENT] = Fetch_Env();
  742.       Free[THUNK_PROCEDURE] =
  743.         FAST_MEMORY_REF (Fetch_Expression(), DELAY_OBJECT);
  744.       Free += 2;
  745.       break;
  746.  
  747.     case TC_DISJUNCTION:
  748.      Will_Push(CONTINUATION_SIZE + 1);
  749.       Save_Env();
  750.       Do_Nth_Then(RC_DISJUNCTION_DECIDE, OR_PREDICATE, Pushed());
  751.  
  752.     case TC_EXTENDED_LAMBDA:    /* Close the procedure */
  753.     /* Deliberately omitted: Eval_GC_Check(2); */
  754.       Val = MAKE_POINTER_OBJECT (TC_EXTENDED_PROCEDURE, Free);
  755.       Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
  756.       Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
  757.       Free += 2;
  758.       break;
  759.  
  760. /* Interpret() continues on the next page */
  761.  
  762. /* Interpret(), continued */
  763.  
  764. #ifdef COMPILE_FUTURES
  765.     case TC_FUTURE:
  766.       if (Future_Has_Value(Fetch_Expression()))
  767.       { SCHEME_OBJECT Future = Fetch_Expression();
  768.         if (Future_Is_Keep_Slot(Future)) Log_Touch_Of_Future(Future);
  769.         Reduces_To_Nth(FUTURE_VALUE);
  770.       }
  771.       Prepare_Eval_Repeat();
  772.      Will_Push(STACK_ENV_EXTRA_SLOTS+2);
  773.       STACK_PUSH (Fetch_Expression());    /* Arg: FUTURE object */
  774.       STACK_PUSH (Get_Fixed_Obj_Slot(System_Scheduler));
  775.       STACK_PUSH (STACK_FRAME_HEADER+1);
  776.      Pushed();
  777.       goto Internal_Apply;
  778. #endif
  779.  
  780.     case TC_IN_PACKAGE:
  781.      Will_Push(CONTINUATION_SIZE);
  782.       Do_Nth_Then(RC_EXECUTE_IN_PACKAGE_CONTINUE,
  783.                   IN_PACKAGE_ENVIRONMENT, Pushed());
  784.  
  785.     case TC_LAMBDA:             /* Close the procedure */
  786.     case TC_LEXPR:
  787.     /* Deliberately omitted: Eval_GC_Check(2); */
  788.       Val = MAKE_POINTER_OBJECT (TC_PROCEDURE, Free);
  789.       Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
  790.       Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
  791.       Free += 2;
  792.       break;
  793.  
  794.     case TC_MANIFEST_NM_VECTOR:
  795.     case TC_MANIFEST_SPECIAL_NM_VECTOR:
  796.       Eval_Error(ERR_EXECUTE_MANIFEST_VECTOR);
  797.  
  798. /* Interpret() continues on the next page */
  799.  
  800. /* Interpret(), continued */
  801.  
  802.     /*
  803.       The argument to Will_Eventually_Push is determined by how much
  804.       will be on the stack if we back out of the primitive.
  805.      */
  806.  
  807.     case TC_PCOMB0:
  808.      Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
  809.      Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
  810.       Store_Expression (OBJECT_NEW_TYPE (TC_PRIMITIVE, (Fetch_Expression ())));
  811.       goto Primitive_Internal_Apply;
  812.  
  813.     case TC_PCOMB1:
  814.      Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
  815.       Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {});
  816.  
  817.     case TC_PCOMB2:
  818.      Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
  819.       Save_Env();
  820.       Do_Nth_Then(RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT, {});
  821.  
  822.     case TC_PCOMB3:
  823.      Will_Eventually_Push(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 3);
  824.       Save_Env();
  825.       Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {});
  826.  
  827.     case TC_SCODE_QUOTE:
  828.       Val = FAST_MEMORY_REF (Fetch_Expression(), SCODE_QUOTE_OBJECT);
  829.       break;
  830.  
  831.     case TC_SEQUENCE_2:
  832.      Will_Push(CONTINUATION_SIZE + 1);
  833.       Save_Env();
  834.       Do_Nth_Then(RC_SEQ_2_DO_2, SEQUENCE_1, Pushed());
  835.  
  836.     case TC_SEQUENCE_3:
  837.      Will_Push(CONTINUATION_SIZE + 1);
  838.       Save_Env();
  839.       Do_Nth_Then(RC_SEQ_3_DO_2, SEQUENCE_1, Pushed());
  840.  
  841.     case TC_THE_ENVIRONMENT:
  842.       Val = Fetch_Env(); break;
  843.  
  844. /* Interpret() continues on the next page */
  845.  
  846. /* Interpret(), continued */
  847.  
  848.     case TC_VARIABLE:
  849.     {
  850.       long temp;
  851.  
  852. #ifndef No_In_Line_Lookup
  853.  
  854.       fast SCHEME_OBJECT *cell;
  855.  
  856.       Set_Time_Zone(Zone_Lookup);
  857.       cell = OBJECT_ADDRESS (Fetch_Expression());
  858.       lookup(cell, Fetch_Env(), cell, repeat_variable_lookup);
  859.  
  860. lookup_end_restart:
  861.  
  862.       Val = MEMORY_FETCH (cell[0]);
  863.       if (OBJECT_TYPE (Val) != TC_REFERENCE_TRAP)
  864.       {
  865.     Set_Time_Zone(Zone_Working);
  866.     goto Pop_Return;
  867.       }
  868.  
  869.       get_trap_kind(temp, Val);
  870.       switch(temp)
  871.       {
  872.     case TRAP_DANGEROUS:
  873.     case TRAP_UNBOUND_DANGEROUS:
  874.     case TRAP_UNASSIGNED_DANGEROUS:
  875.     case TRAP_FLUID_DANGEROUS:
  876.     case TRAP_COMPILER_CACHED_DANGEROUS:
  877.       cell = OBJECT_ADDRESS (Fetch_Expression());
  878.       temp =
  879.         deep_lookup_end(deep_lookup(Fetch_Env(),
  880.                     cell[VARIABLE_SYMBOL],
  881.                     cell),
  882.                 cell);
  883.       Import_Val();
  884.       if (temp != PRIM_DONE)
  885.         break;
  886.       Set_Time_Zone(Zone_Working);
  887.       goto Pop_Return;
  888.  
  889.     case TRAP_COMPILER_CACHED:
  890.       cell = MEMORY_LOC (FAST_MEMORY_REF (Val, TRAP_EXTRA),
  891.                 TRAP_EXTENSION_CELL);
  892.       goto lookup_end_restart;
  893.  
  894.     case TRAP_FLUID:
  895.       cell = lookup_fluid(Val);
  896.       goto lookup_end_restart;
  897.  
  898. /* Interpret() continues on the next page */
  899.  
  900. /* Interpret(), continued */
  901.  
  902.     case TRAP_UNBOUND:
  903.       temp = ERR_UNBOUND_VARIABLE;
  904.       break;
  905.  
  906.     case TRAP_UNASSIGNED:
  907.       temp = ERR_UNASSIGNED_VARIABLE;
  908.       break;
  909.  
  910.     default:
  911.       temp = ERR_ILLEGAL_REFERENCE_TRAP;
  912.       break;
  913.       }
  914.  
  915. #else /* No_In_Line_Lookup */
  916.  
  917.       Set_Time_Zone(Zone_Lookup);
  918.       temp = Lex_Ref(Fetch_Env(), Fetch_Expression());
  919.       Import_Val();
  920.       if (temp == PRIM_DONE)
  921.     goto Pop_Return;
  922.  
  923. #endif /* No_In_Line_Lookup */
  924.  
  925.       /* Back out of the evaluation. */
  926.  
  927.       Set_Time_Zone(Zone_Working);
  928.  
  929.       if (temp == PRIM_INTERRUPT)
  930.       {
  931.     Prepare_Eval_Repeat();
  932.     Interrupt(PENDING_INTERRUPTS());
  933.       }
  934.  
  935.       Eval_Error(temp);
  936.     }
  937.  
  938.     SITE_EXPRESSION_DISPATCH_HOOK()
  939.   };
  940.  
  941. /* Interpret() continues on the next page */
  942.  
  943. /* Interpret(), continued */
  944.  
  945. /* Now restore the continuation saved during an earlier part
  946.  * of the EVAL cycle and continue as directed.
  947.  */
  948.  
  949. Pop_Return:
  950.   if (Microcode_Does_Stepping &&
  951.       Trapping &&
  952.       (! WITHIN_CRITICAL_SECTION_P()) &&
  953.       ((Fetch_Return_Trapper ()) != SHARP_F))
  954.   {
  955.     Will_Push(3);
  956.       Stop_Trapping();
  957.       STACK_PUSH (Val);
  958.       STACK_PUSH (Fetch_Return_Trapper());
  959.       STACK_PUSH (STACK_FRAME_HEADER+1);
  960.     Pushed();
  961.     goto Apply_Non_Trapping;
  962.   }
  963. Pop_Return_Non_Trapping:
  964.   Pop_Return_Ucode_Hook();
  965.   Restore_Cont();
  966.   if (Consistency_Check &&
  967.       (OBJECT_TYPE (Fetch_Return()) != TC_RETURN_CODE))
  968.   { STACK_PUSH (Val);            /* For possible stack trace */
  969.     Save_Cont();
  970.     Export_Registers();
  971.     Microcode_Termination(TERM_BAD_STACK);
  972.   }
  973.   if (Eval_Debug)
  974.   { Print_Return("Pop_Return, return code");
  975.     Print_Expression(Val, "Pop_Return, value");
  976.     printf ("\n");
  977.   };
  978.  
  979.   /* Dispatch on the return code.  A BREAK here will cause
  980.    * a "goto Pop_Return" to occur, since this is the most
  981.    * common occurrence.
  982.    */
  983.  
  984.   switch (OBJECT_DATUM (Fetch_Return()))
  985.   {
  986.     case RC_COMB_1_PROCEDURE:
  987.       Restore_Env();
  988.       STACK_PUSH (Val);                /* Arg. 1 */
  989.       STACK_PUSH (SHARP_F);                /* Operator */
  990.       STACK_PUSH (STACK_FRAME_HEADER + 1);
  991.      Finished_Eventual_Pushing(CONTINUATION_SIZE);
  992.       Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN);
  993.  
  994.     case RC_COMB_2_FIRST_OPERAND:
  995.       Restore_Env();
  996.       STACK_PUSH (Val);
  997.       Save_Env();
  998.       Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
  999.  
  1000. /* Interpret() continues on the next page */
  1001.  
  1002. /* Interpret(), continued */
  1003.  
  1004.     case RC_COMB_2_PROCEDURE:
  1005.       Restore_Env();
  1006.       STACK_PUSH (Val);                /* Arg 1, just calculated */
  1007.       STACK_PUSH (SHARP_F);        /* Function */
  1008.       STACK_PUSH (STACK_FRAME_HEADER + 2);
  1009.      Finished_Eventual_Pushing(CONTINUATION_SIZE);
  1010.       Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN);
  1011.  
  1012.     case RC_COMB_APPLY_FUNCTION:
  1013.        End_Subproblem();
  1014.        goto Internal_Apply_Val;
  1015.  
  1016.     case RC_COMB_SAVE_VALUE:
  1017.       {    long Arg_Number;
  1018.  
  1019.         Restore_Env();
  1020.         Arg_Number = OBJECT_DATUM (STACK_REF(STACK_COMB_FINGER))-1;
  1021.         STACK_REF(STACK_COMB_FIRST_ARG+Arg_Number) = Val;
  1022.         STACK_REF(STACK_COMB_FINGER) =
  1023.           MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Arg_Number);
  1024.     /* DO NOT count on the type code being NMVector here, since
  1025.        the stack parser may create them with #F here! */
  1026.         if (Arg_Number > 0)
  1027.         { Save_Env();
  1028.           Do_Another_Then(RC_COMB_SAVE_VALUE,
  1029.                           (COMB_ARG_1_SLOT - 1) + Arg_Number);
  1030.         }
  1031.     STACK_PUSH (FAST_MEMORY_REF (Fetch_Expression(), 0)); /* Frame Size */
  1032.         Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
  1033.       }
  1034.  
  1035. /* Interpret() continues on the next page */
  1036.  
  1037. /* Interpret(), continued */
  1038.  
  1039. #define define_compiler_restart(return_code, entry)            \
  1040.     case return_code:                            \
  1041.       {                                    \
  1042.     extern long entry();                        \
  1043.     compiled_code_restart();                    \
  1044.     Export_Registers();                        \
  1045.     Which_Way = entry();                        \
  1046.     goto return_from_compiled_code;                    \
  1047.       }
  1048.  
  1049.       define_compiler_restart (RC_COMP_INTERRUPT_RESTART,
  1050.                    comp_interrupt_restart)
  1051.  
  1052.       define_compiler_restart (RC_COMP_LOOKUP_APPLY_RESTART,
  1053.                    comp_lookup_apply_restart)
  1054.  
  1055.       define_compiler_restart (RC_COMP_REFERENCE_RESTART,
  1056.                    comp_reference_restart)
  1057.  
  1058.       define_compiler_restart (RC_COMP_ACCESS_RESTART,
  1059.                    comp_access_restart)
  1060.  
  1061.       define_compiler_restart (RC_COMP_UNASSIGNED_P_RESTART,
  1062.                    comp_unassigned_p_restart)
  1063.  
  1064.       define_compiler_restart (RC_COMP_UNBOUND_P_RESTART,
  1065.                    comp_unbound_p_restart)
  1066.  
  1067.       define_compiler_restart (RC_COMP_ASSIGNMENT_RESTART,
  1068.                    comp_assignment_restart)
  1069.  
  1070.       define_compiler_restart (RC_COMP_DEFINITION_RESTART,
  1071.                    comp_definition_restart)
  1072.  
  1073.       define_compiler_restart (RC_COMP_SAFE_REFERENCE_RESTART,
  1074.                    comp_safe_reference_restart)
  1075.  
  1076.       define_compiler_restart (RC_COMP_LOOKUP_TRAP_RESTART,
  1077.                    comp_lookup_trap_restart)
  1078.  
  1079.       define_compiler_restart (RC_COMP_ASSIGNMENT_TRAP_RESTART,
  1080.                    comp_assignment_trap_restart)
  1081.  
  1082.       define_compiler_restart (RC_COMP_OP_REF_TRAP_RESTART,
  1083.                    comp_op_lookup_trap_restart)
  1084.  
  1085.       define_compiler_restart (RC_COMP_CACHE_REF_APPLY_RESTART,
  1086.                    comp_cache_lookup_apply_restart)
  1087.  
  1088.       define_compiler_restart (RC_COMP_SAFE_REF_TRAP_RESTART,
  1089.                    comp_safe_lookup_trap_restart)
  1090.  
  1091.       define_compiler_restart (RC_COMP_UNASSIGNED_TRAP_RESTART,
  1092.                    comp_unassigned_p_trap_restart)
  1093.  
  1094.       define_compiler_restart (RC_COMP_LINK_CACHES_RESTART,
  1095.                    comp_link_caches_restart)
  1096.  
  1097.       define_compiler_restart (RC_COMP_ERROR_RESTART,
  1098.                    comp_error_restart)
  1099.  
  1100.     case RC_REENTER_COMPILED_CODE:
  1101.       compiled_code_restart();
  1102.       Export_Registers();
  1103.       Which_Way = return_to_compiled_code();
  1104.       goto return_from_compiled_code;
  1105.  
  1106.     case RC_CONDITIONAL_DECIDE:
  1107.       Pop_Return_Val_Check();
  1108.       End_Subproblem();
  1109.       Restore_Env();
  1110.       Reduces_To_Nth ((Val == SHARP_F) ? COND_ALTERNATIVE : COND_CONSEQUENT);
  1111.  
  1112.     case RC_DISJUNCTION_DECIDE:
  1113.       /* Return predicate if it isn't #F; else do ALTERNATIVE */
  1114.       Pop_Return_Val_Check();
  1115.       End_Subproblem();
  1116.       Restore_Env();
  1117.       if (Val != SHARP_F) goto Pop_Return;
  1118.       Reduces_To_Nth(OR_ALTERNATIVE);
  1119.  
  1120.     case RC_END_OF_COMPUTATION:
  1121.       /* Signals bottom of stack */
  1122.       Export_Registers();
  1123.       termination_end_of_computation ();
  1124.  
  1125.     case RC_EVAL_ERROR:
  1126.       /* Should be called RC_REDO_EVALUATION. */
  1127.       Store_Env(STACK_POP ());
  1128.       Reduces_To(Fetch_Expression());
  1129.  
  1130.     case RC_EXECUTE_ACCESS_FINISH:
  1131.     {
  1132.       long Result;
  1133.       SCHEME_OBJECT value;
  1134.  
  1135.       Pop_Return_Val_Check();
  1136.       value = Val;
  1137.  
  1138.       if (ENVIRONMENT_P (Val))
  1139.       { Result = Symbol_Lex_Ref(value,
  1140.                 FAST_MEMORY_REF (Fetch_Expression(),
  1141.                         ACCESS_NAME));
  1142.     Import_Val();
  1143.     if (Result == PRIM_DONE)
  1144.     {
  1145.       End_Subproblem();
  1146.       break;
  1147.     }
  1148.     if (Result != PRIM_INTERRUPT)
  1149.     {
  1150.       Val = value;
  1151.       Pop_Return_Error(Result);
  1152.     }
  1153.     Prepare_Pop_Return_Interrupt(RC_EXECUTE_ACCESS_FINISH, value);
  1154.     Interrupt(PENDING_INTERRUPTS());
  1155.       }
  1156.       Val = value;
  1157.       Pop_Return_Error(ERR_BAD_FRAME);
  1158.     }
  1159.  
  1160. /* Interpret() continues on the next page */
  1161.  
  1162. /* Interpret(), continued */
  1163.  
  1164.     case RC_EXECUTE_ASSIGNMENT_FINISH:
  1165.     {
  1166.       long temp;
  1167.       SCHEME_OBJECT value;
  1168.       Lock_Handle set_serializer;
  1169.  
  1170. #ifndef No_In_Line_Lookup
  1171.  
  1172.       SCHEME_OBJECT bogus_unassigned;
  1173.       fast SCHEME_OBJECT *cell;
  1174.  
  1175.       Set_Time_Zone(Zone_Lookup);
  1176.       Restore_Env();
  1177.       cell = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME));
  1178.       lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup);
  1179.  
  1180.       value = Val;
  1181.       bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
  1182.       if (value == bogus_unassigned)
  1183.     value = UNASSIGNED_OBJECT;
  1184.  
  1185. assignment_end_before_lock:
  1186.  
  1187.       setup_lock(set_serializer, cell);
  1188.  
  1189. assignment_end_after_lock:
  1190.  
  1191.       Val = *cell;
  1192.  
  1193.       if (OBJECT_TYPE (*cell) != TC_REFERENCE_TRAP)
  1194.       {
  1195. normal_assignment_done:
  1196.     *cell = value;
  1197.     remove_lock(set_serializer);
  1198.     Set_Time_Zone(Zone_Working);
  1199.     End_Subproblem();
  1200.     goto Pop_Return;
  1201.       }
  1202.  
  1203. /* Interpret() continues on the next page */
  1204.  
  1205. /* Interpret(), continued */
  1206.  
  1207.       get_trap_kind(temp, *cell);
  1208.       switch(temp)
  1209.       {
  1210.     case TRAP_DANGEROUS:
  1211.     case TRAP_UNBOUND_DANGEROUS:
  1212.     case TRAP_UNASSIGNED_DANGEROUS:
  1213.     case TRAP_FLUID_DANGEROUS:
  1214.     case TRAP_COMPILER_CACHED_DANGEROUS:
  1215.       remove_lock(set_serializer);
  1216.       cell = OBJECT_ADDRESS (MEMORY_REF (Fetch_Expression(), ASSIGN_NAME));
  1217.       temp =
  1218.         deep_assignment_end(deep_lookup(Fetch_Env(),
  1219.                         cell[VARIABLE_SYMBOL],
  1220.                         cell),
  1221.                 cell,
  1222.                 value,
  1223.                 false);
  1224. external_assignment_return:
  1225.       Import_Val();
  1226.       if (temp != PRIM_DONE)
  1227.         break;
  1228.       Set_Time_Zone(Zone_Working);
  1229.       End_Subproblem();
  1230.       goto Pop_Return;
  1231.  
  1232.     case TRAP_COMPILER_CACHED:
  1233.     {
  1234.       SCHEME_OBJECT extension, references;
  1235.  
  1236.       extension = FAST_MEMORY_REF (Val, TRAP_EXTRA);
  1237.       references = FAST_MEMORY_REF (extension, TRAP_EXTENSION_REFERENCES);
  1238.  
  1239.       if ((FAST_MEMORY_REF (references, TRAP_REFERENCES_OPERATOR))
  1240.           != SHARP_F)
  1241.       {
  1242.  
  1243.         /* There are uuo links.
  1244.            wimp out and let deep_assignment_end handle it.
  1245.          */
  1246.  
  1247.         remove_lock(set_serializer);
  1248.         temp = deep_assignment_end(cell,
  1249.                        fake_variable_object,
  1250.                        value,
  1251.                        false);
  1252.         goto external_assignment_return;
  1253.       }
  1254.       cell = MEMORY_LOC (extension, TRAP_EXTENSION_CELL);
  1255.       update_lock(set_serializer, cell);
  1256.       goto assignment_end_after_lock;
  1257.     }
  1258.  
  1259. /* Interpret() continues on the next page */
  1260.  
  1261. /* Interpret(), continued */
  1262.  
  1263.     case TRAP_FLUID:
  1264.       remove_lock(set_serializer);
  1265.       cell = lookup_fluid(Val);
  1266.       goto assignment_end_before_lock;
  1267.  
  1268.     case TRAP_UNBOUND:
  1269.       remove_lock(set_serializer);
  1270.       temp = ERR_UNBOUND_VARIABLE;
  1271.       break;
  1272.  
  1273.     case TRAP_UNASSIGNED:
  1274.       Val = bogus_unassigned;
  1275.       goto normal_assignment_done;
  1276.  
  1277.     default:
  1278.       remove_lock(set_serializer);
  1279.       temp = ERR_ILLEGAL_REFERENCE_TRAP;
  1280.       break;
  1281.       }
  1282.  
  1283.       if (value == UNASSIGNED_OBJECT)
  1284.     value = bogus_unassigned;
  1285.  
  1286. /* Interpret() continues on the next page */
  1287.  
  1288. /* Interpret(), continued */
  1289.  
  1290. #else /* No_In_Line_Lookup */
  1291.  
  1292.       value = Val;
  1293.       Set_Time_Zone(Zone_Lookup);
  1294.       Restore_Env();
  1295.       temp = Lex_Set(Fetch_Env(),
  1296.              MEMORY_REF (Fetch_Expression(), ASSIGN_NAME),
  1297.              value);
  1298.       Import_Val();
  1299.       if (temp == PRIM_DONE)
  1300.       {
  1301.     End_Subproblem();
  1302.     Set_Time_Zone(Zone_Working);
  1303.     break;
  1304.       }
  1305.  
  1306. #endif /* No_In_Line_Lookup */
  1307.  
  1308.       Set_Time_Zone(Zone_Working);
  1309.       Save_Env();
  1310.       if (temp != PRIM_INTERRUPT)
  1311.       {
  1312.     Val = value;
  1313.     Pop_Return_Error(temp);
  1314.       }
  1315.  
  1316.       Prepare_Pop_Return_Interrupt(RC_EXECUTE_ASSIGNMENT_FINISH,
  1317.                    value);
  1318.       Interrupt(PENDING_INTERRUPTS());
  1319.     }
  1320.  
  1321. /* Interpret() continues on the next page */
  1322.  
  1323. /* Interpret(), continued */
  1324.  
  1325.     case RC_EXECUTE_DEFINITION_FINISH:
  1326.       {
  1327.     SCHEME_OBJECT value;
  1328.         long result;
  1329.  
  1330.     value = Val;
  1331.         Restore_Env();
  1332.     Export_Registers();
  1333.         result = Local_Set(Fetch_Env(),
  1334.                FAST_MEMORY_REF (Fetch_Expression(), DEFINE_NAME),
  1335.                Val);
  1336.         Import_Registers();
  1337.         if (result == PRIM_DONE)
  1338.         {
  1339.       End_Subproblem();
  1340.           break;
  1341.     }
  1342.     Save_Env();
  1343.     if (result == PRIM_INTERRUPT)
  1344.     {
  1345.       Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH,
  1346.                        value);
  1347.       Interrupt(PENDING_INTERRUPTS());
  1348.     }
  1349.     Val = value;
  1350.         Pop_Return_Error(result);
  1351.       }
  1352.  
  1353.     case RC_EXECUTE_IN_PACKAGE_CONTINUE:
  1354.       Pop_Return_Val_Check();
  1355.       if (ENVIRONMENT_P (Val))
  1356.       {
  1357.     End_Subproblem();
  1358.         Store_Env(Val);
  1359.         Reduces_To_Nth(IN_PACKAGE_EXPRESSION);
  1360.       }
  1361.       Pop_Return_Error(ERR_BAD_FRAME);
  1362.  
  1363. #ifdef COMPILE_FUTURES
  1364.     case RC_FINISH_GLOBAL_INT:
  1365.       Export_Registers();
  1366.       Val = Global_Int_Part_2(Fetch_Expression(), Val);
  1367.       Import_Registers_Except_Val();
  1368.       break;
  1369. #endif
  1370.  
  1371.     case RC_HALT:
  1372.       Export_Registers();
  1373.       Microcode_Termination(TERM_TERM_HANDLER);
  1374.  
  1375.     case RC_HARDWARE_TRAP:
  1376.     {
  1377.       /* This just reinvokes the handler */
  1378.  
  1379.       SCHEME_OBJECT info, handler;
  1380.       info = (STACK_REF (0));
  1381.  
  1382.       Save_Cont();
  1383.       if ((! (Valid_Fixed_Obj_Vector())) ||
  1384.       ((handler = (Get_Fixed_Obj_Slot(Trap_Handler))) == SHARP_F))
  1385.       {
  1386.     fprintf(stderr, "There is no trap handler for recovery!\n");
  1387.     termination_trap ();
  1388.     /*NOTREACHED*/
  1389.       }
  1390.      Will_Push(STACK_ENV_EXTRA_SLOTS + 2);
  1391.       STACK_PUSH (info);
  1392.       STACK_PUSH (handler);
  1393.       STACK_PUSH (STACK_FRAME_HEADER + 1);
  1394.      Pushed();
  1395.       goto Internal_Apply;
  1396.     }
  1397.  
  1398. /* Internal_Apply, the core of the application mechanism.
  1399.  
  1400.    Branch here to perform a function application.
  1401.  
  1402.    At this point the top of the stack contains an application frame
  1403.    which consists of the following elements (see sdata.h):
  1404.    - A header specifying the frame length.
  1405.    - A procedure.
  1406.    - The actual (evaluated) arguments.
  1407.  
  1408.    No registers (except the stack pointer) are meaning full at this point.
  1409.    Before interrupts or errors are processed, some registers are cleared
  1410.    to avoid holding onto garbage if a garbage collection occurs.
  1411. */
  1412.  
  1413. #define Prepare_Apply_Interrupt()                    \
  1414. {                                    \
  1415.   Store_Expression (SHARP_F);                        \
  1416.   Prepare_Pop_Return_Interrupt (RC_INTERNAL_APPLY_VAL,            \
  1417.                 (STACK_REF (STACK_ENV_FUNCTION)));    \
  1418. }
  1419.  
  1420. #define Apply_Error(N)                            \
  1421. {                                    \
  1422.   Store_Expression (SHARP_F);                        \
  1423.   Store_Return (RC_INTERNAL_APPLY_VAL);                    \
  1424.   Val = (STACK_REF (STACK_ENV_FUNCTION));                \
  1425.   Pop_Return_Error (N);                            \
  1426. }
  1427.  
  1428. /* Interpret() continues on the next page */
  1429.  
  1430. /* Interpret(), continued */
  1431.  
  1432.     case RC_INTERNAL_APPLY_VAL:
  1433. Internal_Apply_Val:
  1434.  
  1435.        STACK_REF (STACK_ENV_FUNCTION) = Val;
  1436.  
  1437.     case RC_INTERNAL_APPLY:
  1438. Internal_Apply:
  1439.  
  1440.       if (Microcode_Does_Stepping &&
  1441.       Trapping &&
  1442.       (! WITHIN_CRITICAL_SECTION_P()) &&
  1443.       ((Fetch_Apply_Trapper ()) != SHARP_F))
  1444.       {
  1445.     long Count;
  1446.  
  1447.     Count = (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));
  1448.         (* (STACK_LOC (0))) = (Fetch_Apply_Trapper ());
  1449.         STACK_PUSH (STACK_FRAME_HEADER + Count);
  1450.         Stop_Trapping ();
  1451.       }
  1452.  
  1453. Apply_Non_Trapping:
  1454.  
  1455.       if ((PENDING_INTERRUPTS()) != 0)
  1456.       {
  1457.     long Interrupts;
  1458.  
  1459.     Interrupts = (PENDING_INTERRUPTS());
  1460.     Prepare_Apply_Interrupt ();
  1461.     Interrupt(Interrupts);
  1462.       }
  1463.  
  1464. Perform_Application:
  1465.  
  1466.       Apply_Ucode_Hook();
  1467.  
  1468.       {
  1469.         fast SCHEME_OBJECT Function;
  1470.  
  1471.     Apply_Future_Check(Function, STACK_REF(STACK_ENV_FUNCTION));
  1472.  
  1473.         switch(OBJECT_TYPE (Function))
  1474.         {
  1475.  
  1476.       case TC_ENTITY:
  1477.       {
  1478.         fast long nargs;
  1479.  
  1480.         /* Will_Pushed ommited since frame must be contiguous.
  1481.            combination code must ensure one more slot.
  1482.          */
  1483.  
  1484.         /* This code assumes that adding 1 to nargs takes care
  1485.            of everything, including type code, etc.
  1486.          */
  1487.  
  1488.         nargs = (STACK_POP ());
  1489.         STACK_PUSH (FAST_MEMORY_REF (Function, ENTITY_OPERATOR));
  1490.         STACK_PUSH (nargs + 1);
  1491.         /* This must be done to prevent an infinite push loop by
  1492.            an entity whose handler is the entity itself or some
  1493.            other such loop.  Of course, it will die if stack overflow
  1494.            interrupts are disabled.
  1495.            This will not work in fscheme!  It has to be thought out
  1496.            carefully.
  1497.          */
  1498.         Stack_Check(Stack_Pointer);
  1499.         goto Internal_Apply;
  1500.       }
  1501.  
  1502. /* Interpret() continues on the next page */
  1503.  
  1504. /* Interpret(), continued */
  1505.  
  1506.       case TC_PROCEDURE:
  1507.       {
  1508.         fast long nargs;
  1509.  
  1510.             nargs = OBJECT_DATUM (STACK_POP ());
  1511.         Function = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR);
  1512.  
  1513.         {
  1514.           fast SCHEME_OBJECT formals;
  1515.  
  1516.           Apply_Future_Check(formals,
  1517.                  FAST_MEMORY_REF (Function, LAMBDA_FORMALS));
  1518.  
  1519.           if ((nargs != VECTOR_LENGTH (formals)) &&
  1520.           ((OBJECT_TYPE (Function) != TC_LEXPR) ||
  1521.           (nargs < VECTOR_LENGTH (formals))))
  1522.           {
  1523.         STACK_PUSH (STACK_FRAME_HEADER + nargs - 1);
  1524.         Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
  1525.           }
  1526.         }
  1527.  
  1528.         if (Eval_Debug)
  1529.         {
  1530.           Print_Expression(LONG_TO_UNSIGNED_FIXNUM(nargs),
  1531.                    "APPLY: Number of arguments");
  1532.         }
  1533.  
  1534.             if (GC_Check(nargs + 1))
  1535.             {
  1536.           STACK_PUSH (STACK_FRAME_HEADER + nargs - 1);
  1537.               Prepare_Apply_Interrupt ();
  1538.               Immediate_GC(nargs + 1);
  1539.             }
  1540.  
  1541.         {
  1542.           fast SCHEME_OBJECT *scan;
  1543.  
  1544.           scan = Free;
  1545.           Store_Env(MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan));
  1546.           *scan++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, nargs);
  1547.           while(--nargs >= 0)
  1548.         *scan++ = (STACK_POP ());
  1549.           Free = scan;
  1550.           Reduces_To(FAST_MEMORY_REF (Function, LAMBDA_SCODE));
  1551.         }
  1552.           }
  1553.  
  1554. /* Interpret() continues on the next page */
  1555.  
  1556. /* Interpret(), continued */
  1557.  
  1558.           case TC_CONTROL_POINT:
  1559.       {
  1560.             if (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)) !=
  1561.                 STACK_ENV_FIRST_ARG)
  1562.         {
  1563.               Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
  1564.         }
  1565.             Val = (STACK_REF (STACK_ENV_FIRST_ARG));
  1566.             Our_Throw(false, Function);
  1567.         Apply_Stacklet_Backout();
  1568.         Our_Throw_Part_2();
  1569.             goto Pop_Return;
  1570.       }
  1571.  
  1572. /* Interpret() continues on the next page */
  1573.  
  1574. /* Interpret(), continued */
  1575.  
  1576.       /*
  1577.          After checking the number of arguments, remove the
  1578.          frame header since primitives do not expect it.
  1579.  
  1580.          NOTE: This code must match the application code which
  1581.          follows Primitive_Internal_Apply.
  1582.        */
  1583.  
  1584.           case TC_PRIMITIVE:
  1585.           {
  1586.         fast long nargs;
  1587.  
  1588.         if (!IMPLEMENTED_PRIMITIVE_P(Function))
  1589.         {
  1590.           Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE);
  1591.         }
  1592.  
  1593.         /* Note that the first test below will fail for lexpr primitives. */
  1594.  
  1595.         nargs = ((OBJECT_DATUM (STACK_REF(STACK_ENV_HEADER))) -
  1596.              (STACK_ENV_FIRST_ARG - 1));
  1597.             if (nargs != PRIMITIVE_ARITY(Function))
  1598.         {
  1599.           if (PRIMITIVE_ARITY(Function) != LEXPR_PRIMITIVE_ARITY)
  1600.           {
  1601.         Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
  1602.           }
  1603.           Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) nargs);
  1604.         }
  1605.  
  1606.             Stack_Pointer = (STACK_LOC (STACK_ENV_FIRST_ARG));
  1607.             Store_Expression (Function);
  1608.         EXPORT_REGS_BEFORE_PRIMITIVE ();
  1609.         PRIMITIVE_APPLY (Val, Function);
  1610.         IMPORT_REGS_AFTER_PRIMITIVE ();
  1611.         POP_PRIMITIVE_FRAME (nargs);
  1612.         if (Must_Report_References())
  1613.         {
  1614.           Store_Expression(Val);
  1615.           Store_Return(RC_RESTORE_VALUE);
  1616.           Save_Cont();
  1617.           Call_Future_Logging();
  1618.         }
  1619.         goto Pop_Return;
  1620.       }
  1621.  
  1622. /* Interpret() continues on the next page */
  1623.  
  1624. /* Interpret(), continued */
  1625.  
  1626.           case TC_EXTENDED_PROCEDURE:
  1627.           {
  1628.         SCHEME_OBJECT lambda;
  1629.             long nargs, nparams, formals, params, auxes,
  1630.                  rest_flag, size;
  1631.  
  1632.         fast long i;
  1633.         fast SCHEME_OBJECT *scan;
  1634.  
  1635.             nargs = OBJECT_DATUM (STACK_POP ()) - STACK_FRAME_HEADER;
  1636.  
  1637.         if (Eval_Debug)
  1638.         {
  1639.           Print_Expression(LONG_TO_UNSIGNED_FIXNUM(nargs+STACK_FRAME_HEADER),
  1640.                    "APPLY: Number of arguments");
  1641.         }
  1642.  
  1643.             lambda = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR);
  1644.         Apply_Future_Check(Function,
  1645.                    FAST_MEMORY_REF (lambda, ELAMBDA_NAMES));
  1646.             nparams = VECTOR_LENGTH (Function) - 1;
  1647.  
  1648.         Apply_Future_Check(Function, Get_Count_Elambda(lambda));
  1649.             formals = Elambda_Formals_Count(Function);
  1650.             params = Elambda_Opts_Count(Function) + formals;
  1651.             rest_flag = Elambda_Rest_Flag(Function);
  1652.             auxes = nparams - (params + rest_flag);
  1653.  
  1654.             if ((nargs < formals) || (!rest_flag && (nargs > params)))
  1655.             {
  1656.           STACK_PUSH (STACK_FRAME_HEADER + nargs);
  1657.               Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
  1658.             }
  1659.  
  1660.         /* size includes the procedure slot, but not the header. */
  1661.             size = params + rest_flag + auxes + 1;
  1662.             if (GC_Check(size + 1 + ((nargs > params) ?
  1663.                      (2 * (nargs - params)) :
  1664.                      0)))
  1665.             {
  1666.           STACK_PUSH (STACK_FRAME_HEADER + nargs);
  1667.               Prepare_Apply_Interrupt ();
  1668.               Immediate_GC(size + 1 + ((nargs > params) ?
  1669.                        (2 * (nargs - params)) :
  1670.                        0));
  1671.             }
  1672.  
  1673. /* Interpret() continues on the next page */
  1674.  
  1675. /* Interpret(), continued */
  1676.  
  1677.         scan = Free;
  1678.             Store_Env(MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan));
  1679.         *scan++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, size);
  1680.  
  1681.         if (nargs <= params)
  1682.         {
  1683.           for (i = (nargs + 1); --i >= 0; )
  1684.         *scan++ = (STACK_POP ());
  1685.           for (i = (params - nargs); --i >= 0; )
  1686.         *scan++ = UNASSIGNED_OBJECT;
  1687.           if (rest_flag)
  1688.         *scan++ = EMPTY_LIST;
  1689.           for (i = auxes; --i >= 0; )
  1690.         *scan++ = UNASSIGNED_OBJECT;
  1691.         }
  1692.         else
  1693.         {
  1694.           /* rest_flag must be true. */
  1695.           SCHEME_OBJECT list;
  1696.  
  1697.           list = MAKE_POINTER_OBJECT (TC_LIST, (scan + size));
  1698.           for (i = (params + 1); --i >= 0; )
  1699.         *scan++ = (STACK_POP ());
  1700.           *scan++ = list;
  1701.           for (i = auxes; --i >= 0; )
  1702.         *scan++ = UNASSIGNED_OBJECT;
  1703.           /* Now scan == OBJECT_ADDRESS (list) */
  1704.           for (i = (nargs - params); --i >= 0; )
  1705.           {
  1706.         *scan++ = (STACK_POP ());
  1707.         *scan = MAKE_POINTER_OBJECT (TC_LIST, (scan + 1));
  1708.         scan += 1;
  1709.           }
  1710.           scan[-1] = EMPTY_LIST;
  1711.         }
  1712.  
  1713.         Free = scan;
  1714.             Reduces_To(Get_Body_Elambda(lambda));
  1715.           }
  1716.  
  1717. /* Interpret() continues on the next page */
  1718.  
  1719. /* Interpret(), continued */
  1720.  
  1721.           case TC_COMPILED_ENTRY:
  1722.       {
  1723.         apply_compiled_setup (STACK_ENV_EXTRA_SLOTS +
  1724.                   (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER))));
  1725.         Export_Registers ();
  1726.         Which_Way = apply_compiled_procedure();
  1727.  
  1728. return_from_compiled_code:
  1729.         Import_Registers ();
  1730.             switch (Which_Way)
  1731.             {
  1732.         case PRIM_DONE:
  1733.         {
  1734.           compiled_code_done ();
  1735.           goto Pop_Return;
  1736.         }
  1737.  
  1738.         case PRIM_APPLY:
  1739.         {
  1740.           compiler_apply_procedure
  1741.         (STACK_ENV_EXTRA_SLOTS +
  1742.          OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));
  1743.           goto Internal_Apply;
  1744.         }
  1745.  
  1746.         case PRIM_INTERRUPT:
  1747.         {
  1748.           compiled_error_backout ();
  1749.           Save_Cont ();
  1750.           Interrupt (PENDING_INTERRUPTS ());
  1751.         }
  1752.  
  1753.         case PRIM_APPLY_INTERRUPT:
  1754.         {
  1755.           apply_compiled_backout ();
  1756.           Prepare_Apply_Interrupt ();
  1757.           Interrupt (PENDING_INTERRUPTS ());
  1758.         }
  1759.  
  1760.         case ERR_INAPPLICABLE_OBJECT:
  1761.         /* This error code means that apply_compiled_procedure
  1762.            was called on an object which is not a compiled procedure,
  1763.            or it was called in a system without compiler support.
  1764.  
  1765.            Fall through...
  1766.          */
  1767.  
  1768.         case ERR_WRONG_NUMBER_OF_ARGUMENTS:
  1769.         {
  1770.           apply_compiled_backout ();
  1771.           Apply_Error (Which_Way);
  1772.         }
  1773.  
  1774.         case ERR_EXECUTE_MANIFEST_VECTOR:
  1775.         {
  1776.           /* This error code means that enter_compiled_expression
  1777.          was called in a system without compiler support.
  1778.          This is a kludge!
  1779.            */
  1780.  
  1781.           execute_compiled_backout ();
  1782.           Val =
  1783.         (OBJECT_NEW_TYPE (TC_COMPILED_ENTRY, (Fetch_Expression ())));
  1784.           Pop_Return_Error (Which_Way);
  1785.         }
  1786.  
  1787.         case ERR_INAPPLICABLE_CONTINUATION:
  1788.         {
  1789.           /* This error code means that return_to_compiled_code
  1790.          saw a non-continuation on the stack, or was called
  1791.          in a system without compiler support.
  1792.            */
  1793.  
  1794.           Store_Expression (SHARP_F);
  1795.           Store_Return (RC_REENTER_COMPILED_CODE);
  1796.           Pop_Return_Error (Which_Way);
  1797.         }
  1798.  
  1799.         default:
  1800.           compiled_error_backout ();
  1801.           Pop_Return_Error (Which_Way);
  1802.             }
  1803.           }
  1804.  
  1805.           default:
  1806.             Apply_Error (ERR_INAPPLICABLE_OBJECT);
  1807.         }       /* End of switch in RC_INTERNAL_APPLY */
  1808.       }         /* End of RC_INTERNAL_APPLY case */
  1809.  
  1810. /* Interpret() continues on the next page */
  1811.  
  1812. /* Interpret(), continued */
  1813.  
  1814.     case RC_MOVE_TO_ADJACENT_POINT:
  1815.     /* Expression contains the space in which we are moving */
  1816.     {
  1817.       long From_Count;
  1818.       SCHEME_OBJECT Thunk, New_Location;
  1819.  
  1820.       From_Count =
  1821.     (UNSIGNED_FIXNUM_TO_LONG (STACK_REF (TRANSLATE_FROM_DISTANCE)));
  1822.       if (From_Count != 0)
  1823.       { SCHEME_OBJECT Current = STACK_REF(TRANSLATE_FROM_POINT);
  1824.     STACK_REF(TRANSLATE_FROM_DISTANCE) =
  1825.       (LONG_TO_UNSIGNED_FIXNUM (From_Count - 1));
  1826.     Thunk = FAST_MEMORY_REF (Current, STATE_POINT_AFTER_THUNK);
  1827.     New_Location = FAST_MEMORY_REF (Current, STATE_POINT_NEARER_POINT);
  1828.     STACK_REF(TRANSLATE_FROM_POINT) = New_Location;
  1829.     if ((From_Count == 1) &&
  1830.         (STACK_REF(TRANSLATE_TO_DISTANCE) == LONG_TO_UNSIGNED_FIXNUM(0)))
  1831.       Stack_Pointer = (STACK_LOC (4));
  1832.     else Save_Cont();
  1833.       }
  1834.       else
  1835.       {
  1836.     long To_Count;
  1837.     fast SCHEME_OBJECT To_Location;
  1838.     fast long i;
  1839.  
  1840.     To_Count =
  1841.       (UNSIGNED_FIXNUM_TO_LONG (STACK_REF (TRANSLATE_TO_DISTANCE)) -  1);
  1842.     To_Location = STACK_REF(TRANSLATE_TO_POINT);
  1843.     for (i = 0; i < To_Count; i++)
  1844.     {
  1845.       To_Location =
  1846.         (FAST_MEMORY_REF (To_Location, STATE_POINT_NEARER_POINT));
  1847.     }
  1848.     Thunk = FAST_MEMORY_REF (To_Location, STATE_POINT_BEFORE_THUNK);
  1849.     New_Location = To_Location;
  1850.     STACK_REF(TRANSLATE_TO_DISTANCE) = LONG_TO_UNSIGNED_FIXNUM(To_Count);
  1851.     if (To_Count == 0)
  1852.     {
  1853.       Stack_Pointer = (STACK_LOC (4));
  1854.     }
  1855.     else
  1856.     {
  1857.       Save_Cont();
  1858.     }
  1859.       }
  1860.       if ((Fetch_Expression ()) != SHARP_F)
  1861.       {
  1862.         MEMORY_SET
  1863.       ((Fetch_Expression ()), STATE_SPACE_NEAREST_POINT, New_Location);
  1864.       }
  1865.       else
  1866.       {
  1867.     Current_State_Point = New_Location;
  1868.       }
  1869.      Will_Push(2);
  1870.       STACK_PUSH (Thunk);
  1871.       STACK_PUSH (STACK_FRAME_HEADER);
  1872.      Pushed();
  1873.       goto Internal_Apply;
  1874.     }
  1875.  
  1876. /* Interpret() continues on the next page */
  1877.  
  1878. /* Interpret(), continued */
  1879.  
  1880.     case RC_INVOKE_STACK_THREAD:
  1881.       /* Used for WITH_THREADED_STACK primitive */
  1882.      Will_Push(3);
  1883.       STACK_PUSH (Val);        /* Value calculated by thunk */
  1884.       STACK_PUSH (Fetch_Expression());
  1885.       STACK_PUSH (STACK_FRAME_HEADER+1);
  1886.      Pushed();
  1887.       goto Internal_Apply;
  1888.  
  1889.     case RC_JOIN_STACKLETS:
  1890.       Our_Throw(true, Fetch_Expression());
  1891.       Join_Stacklet_Backout();
  1892.       Our_Throw_Part_2();
  1893.       break;
  1894.  
  1895.     case RC_NORMAL_GC_DONE:
  1896.       Val = Fetch_Expression();
  1897.       if (GC_Space_Needed < 0)
  1898.       {
  1899.     /* Paranoia */
  1900.  
  1901.     GC_Space_Needed = 0;
  1902.       }
  1903.       if (GC_Check(GC_Space_Needed))
  1904.     termination_gc_out_of_space ();
  1905.       GC_Space_Needed = 0;
  1906.       EXIT_CRITICAL_SECTION ({ Save_Cont(); Export_Registers(); });
  1907.       End_GC_Hook();
  1908.       break;
  1909.  
  1910.     case RC_PCOMB1_APPLY:
  1911.       End_Subproblem();
  1912.       STACK_PUSH (Val);        /* Argument value */
  1913.      Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
  1914.       Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB1_FN_SLOT));
  1915.  
  1916. Primitive_Internal_Apply:
  1917.       if (Microcode_Does_Stepping &&
  1918.       Trapping &&
  1919.       (! WITHIN_CRITICAL_SECTION_P()) &&
  1920.       ((Fetch_Apply_Trapper ()) != SHARP_F))
  1921.       {
  1922.     /* Does this work in the stacklet case?
  1923.        We may have a non-contiguous frame. -- Jinx
  1924.      */
  1925.        Will_Push(3);
  1926.         STACK_PUSH (Fetch_Expression());
  1927.         STACK_PUSH (Fetch_Apply_Trapper());
  1928.         STACK_PUSH (STACK_FRAME_HEADER + 1 +
  1929.          PRIMITIVE_N_PARAMETERS(Fetch_Expression()));
  1930.        Pushed();
  1931.         Stop_Trapping();
  1932.     goto Apply_Non_Trapping;
  1933.       }
  1934.  
  1935.       /* NOTE: This code must match the code in the TC_PRIMITIVE
  1936.      case of Internal_Apply.
  1937.      This code is simpler because:
  1938.      1) The arity was checked at syntax time.
  1939.      2) We don't have to deal with "lexpr" primitives.
  1940.      3) We don't need to worry about unimplemented primitives because
  1941.         unimplemented primitives will cause an error at invocation.
  1942.        */
  1943.  
  1944.       {
  1945.     fast SCHEME_OBJECT primitive = (Fetch_Expression ());
  1946.     EXPORT_REGS_BEFORE_PRIMITIVE ();
  1947.     PRIMITIVE_APPLY (Val, primitive);
  1948.     IMPORT_REGS_AFTER_PRIMITIVE ();
  1949.     POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
  1950.     if (Must_Report_References ())
  1951.       {
  1952.         Store_Expression (Val);
  1953.         Store_Return (RC_RESTORE_VALUE);
  1954.         Save_Cont ();
  1955.         Call_Future_Logging ();
  1956.       }
  1957.     break;
  1958.       }
  1959.  
  1960.     case RC_PCOMB2_APPLY:
  1961.       End_Subproblem();
  1962.       STACK_PUSH (Val);        /* Value of arg. 1 */
  1963.      Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
  1964.       Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB2_FN_SLOT));
  1965.       goto Primitive_Internal_Apply;
  1966.  
  1967.     case RC_PCOMB2_DO_1:
  1968.       Restore_Env();
  1969.       STACK_PUSH (Val);        /* Save value of arg. 2 */
  1970.       Do_Another_Then(RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT);
  1971.  
  1972.     case RC_PCOMB3_APPLY:
  1973.       End_Subproblem();
  1974.       STACK_PUSH (Val);        /* Save value of arg. 1 */
  1975.      Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
  1976.       Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB3_FN_SLOT));
  1977.       goto Primitive_Internal_Apply;
  1978.  
  1979. /* Interpret() continues on the next page */
  1980.  
  1981. /* Interpret(), continued */
  1982.  
  1983.     case RC_PCOMB3_DO_1:
  1984.     {
  1985.       SCHEME_OBJECT Temp;
  1986.  
  1987.       Temp = (STACK_POP ());        /* Value of arg. 3 */
  1988.       Restore_Env();
  1989.       STACK_PUSH (Temp);        /* Save arg. 3 again */
  1990.       STACK_PUSH (Val);        /* Save arg. 2 */
  1991.       Do_Another_Then(RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT);
  1992.     }
  1993.  
  1994.     case RC_PCOMB3_DO_2:
  1995.       Restore_Then_Save_Env();
  1996.       STACK_PUSH (Val);        /* Save value of arg. 3 */
  1997.       Do_Another_Then(RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT);
  1998.  
  1999.     case RC_POP_RETURN_ERROR:
  2000.     case RC_RESTORE_VALUE:
  2001.       Val = Fetch_Expression();
  2002.       break;
  2003.  
  2004.     case RC_PRIMITIVE_CONTINUE:
  2005.       Export_Registers ();
  2006.       Val = (continue_primitive ());
  2007.       Import_Registers ();
  2008.       break;
  2009.  
  2010. /* Interpret() continues on the next page */
  2011.  
  2012. /* Interpret(), continued */
  2013.  
  2014.     case RC_PURIFY_GC_1:
  2015.     {
  2016.       SCHEME_OBJECT GC_Daemon_Proc, Result;
  2017.  
  2018.       RENAME_CRITICAL_SECTION ("purify pass 2");
  2019.       Export_Registers();
  2020.       Result = Purify_Pass_2(Fetch_Expression());
  2021.       Import_Registers();
  2022.       if (Result == SHARP_F)
  2023.     {
  2024.       /* The object does not fit in Constant space.
  2025.          There is no need to run the daemons, and we should let
  2026.          the runtime system know what happened.  */
  2027.       RESULT_OF_PURIFY (SHARP_F);
  2028.       EXIT_CRITICAL_SECTION ({ Export_Registers(); });
  2029.       break;
  2030.     }
  2031.       GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
  2032.       if (GC_Daemon_Proc == SHARP_F)
  2033.     {
  2034.       RESULT_OF_PURIFY (SHARP_T);
  2035.       EXIT_CRITICAL_SECTION ({ Export_Registers(); });
  2036.       break;
  2037.     }
  2038.       RENAME_CRITICAL_SECTION( "purify daemon 2");
  2039.       Store_Expression(SHARP_F);
  2040.       Store_Return(RC_PURIFY_GC_2);
  2041.       Save_Cont();
  2042.      Will_Push(2);
  2043.       STACK_PUSH (GC_Daemon_Proc);
  2044.       STACK_PUSH (STACK_FRAME_HEADER);
  2045.      Pushed();
  2046.       goto Internal_Apply;
  2047.     }
  2048.  
  2049.     case RC_PURIFY_GC_2:
  2050.       RESULT_OF_PURIFY (SHARP_T);
  2051.       EXIT_CRITICAL_SECTION ({ Export_Registers(); });
  2052.       break;
  2053.  
  2054.     case RC_REPEAT_DISPATCH:
  2055.       Which_Way = (FIXNUM_TO_LONG (Fetch_Expression ()));
  2056.       Restore_Env();
  2057.       Val = (STACK_POP ());
  2058.       Restore_Cont();
  2059.       goto Repeat_Dispatch;
  2060.  
  2061. /* Interpret() continues on the next page */
  2062.  
  2063. /* Interpret(), continued */
  2064.  
  2065. /* The following two return codes are both used to restore
  2066.    a saved history object.  The difference is that the first
  2067.    does not copy the history object while the second does.
  2068.    In both cases, the Expression register contains the history
  2069.    object and the next item to be popped off the stack contains
  2070.    the offset back to the previous restore history return code.
  2071.  
  2072.    ASSUMPTION: History objects are never created using futures.
  2073. */
  2074.  
  2075.     case RC_RESTORE_DONT_COPY_HISTORY:
  2076.     {
  2077.       SCHEME_OBJECT Stacklet;
  2078.  
  2079.       Prev_Restore_History_Offset = OBJECT_DATUM (STACK_POP ());
  2080.       Stacklet = (STACK_POP ());
  2081.       History = OBJECT_ADDRESS (Fetch_Expression());
  2082.       if (Prev_Restore_History_Offset == 0)
  2083.       {
  2084.     Prev_Restore_History_Stacklet = NULL;
  2085.       }
  2086.       else if (Stacklet == SHARP_F)
  2087.       {
  2088.         Prev_Restore_History_Stacklet = NULL;
  2089.       }
  2090.       else
  2091.       {
  2092.     Prev_Restore_History_Stacklet = OBJECT_ADDRESS (Stacklet);
  2093.       }
  2094.       break;
  2095.     }
  2096.  
  2097. /* Interpret() continues on the next page */
  2098.  
  2099. /* Interpret(), continued */
  2100.  
  2101.     case RC_RESTORE_HISTORY:
  2102.     {
  2103.       SCHEME_OBJECT Stacklet;
  2104.  
  2105.       Export_Registers();
  2106.       if (! Restore_History(Fetch_Expression()))
  2107.       {
  2108.     Import_Registers();
  2109.         Save_Cont();
  2110.        Will_Push(CONTINUATION_SIZE);
  2111.         Store_Expression(Val);
  2112.         Store_Return(RC_RESTORE_VALUE);
  2113.         Save_Cont();
  2114.        Pushed();
  2115.         Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1));
  2116.       }
  2117.       Import_Registers();
  2118.       Prev_Restore_History_Offset = OBJECT_DATUM (STACK_POP ());
  2119.       Stacklet = (STACK_POP ());
  2120.       if (Prev_Restore_History_Offset == 0)
  2121.     Prev_Restore_History_Stacklet = NULL;
  2122.       else
  2123.       { if (Stacklet == SHARP_F)
  2124.         { Prev_Restore_History_Stacklet = NULL;
  2125.       Get_End_Of_Stacklet()[-Prev_Restore_History_Offset] =
  2126.             MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_HISTORY);
  2127.         }
  2128.         else
  2129.     { Prev_Restore_History_Stacklet = OBJECT_ADDRESS (Stacklet);
  2130.       Prev_Restore_History_Stacklet[-Prev_Restore_History_Offset] =
  2131.             MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_HISTORY);
  2132.         }
  2133.       }
  2134.       break;
  2135.     }
  2136.  
  2137.     case RC_RESTORE_FLUIDS:
  2138.       Fluid_Bindings = Fetch_Expression();
  2139.       /* Why is this here? -- Jinx */
  2140.       COMPILER_SETUP_INTERRUPT();
  2141.       break;
  2142.  
  2143.     case RC_RESTORE_INT_MASK:
  2144.       SET_INTERRUPT_MASK (UNSIGNED_FIXNUM_TO_LONG (Fetch_Expression()));
  2145.       break;
  2146.  
  2147.     case RC_STACK_MARKER:
  2148.       /* Frame consists of the return code followed by two objects.
  2149.      The first object has already been popped into the Expression
  2150.      register, so just pop the second argument. */
  2151.       Stack_Pointer = (STACK_LOCATIVE_OFFSET (Stack_Pointer, 1));
  2152.       break;
  2153.  
  2154. /* Interpret() continues on the next page */
  2155.  
  2156. /* Interpret(), continued */
  2157.  
  2158.     case RC_RESTORE_TO_STATE_POINT:
  2159.     { SCHEME_OBJECT Where_To_Go = Fetch_Expression();
  2160.      Will_Push(CONTINUATION_SIZE);
  2161.       /* Restore the contents of Val after moving to point */
  2162.       Store_Expression(Val);
  2163.       Store_Return(RC_RESTORE_VALUE);
  2164.       Save_Cont();
  2165.      Pushed();
  2166.       Export_Registers();
  2167.       Translate_To_Point(Where_To_Go);
  2168.       break;            /* We never get here.... */
  2169.     }
  2170.  
  2171.     case RC_SEQ_2_DO_2:
  2172.       End_Subproblem();
  2173.       Restore_Env();
  2174.       Reduces_To_Nth(SEQUENCE_2);
  2175.  
  2176.     case RC_SEQ_3_DO_2:
  2177.       Restore_Then_Save_Env();
  2178.       Do_Another_Then(RC_SEQ_3_DO_3, SEQUENCE_2);
  2179.  
  2180.     case RC_SEQ_3_DO_3:
  2181.       End_Subproblem();
  2182.       Restore_Env();
  2183.       Reduces_To_Nth(SEQUENCE_3);
  2184.  
  2185. /* Interpret() continues on the next page */
  2186.  
  2187. /* Interpret(), continued */
  2188.  
  2189.     case RC_SNAP_NEED_THUNK:
  2190.       MEMORY_SET (Fetch_Expression(), THUNK_SNAPPED, SHARP_T);
  2191.       MEMORY_SET (Fetch_Expression(), THUNK_VALUE, Val);
  2192.       break;
  2193.  
  2194.     case RC_AFTER_MEMORY_UPDATE:
  2195.     case RC_BAD_INTERRUPT_CONTINUE:
  2196.     case RC_COMPLETE_GC_DONE:
  2197.     case RC_RESTARTABLE_EXIT:
  2198.     case RC_RESTART_EXECUTION:
  2199.     case RC_RESTORE_CONTINUATION:
  2200.     case RC_RESTORE_STEPPER:
  2201.     case RC_POP_FROM_COMPILED_CODE:
  2202.       Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION);
  2203.  
  2204.     SITE_RETURN_DISPATCH_HOOK()
  2205.  
  2206.     default:
  2207.       Pop_Return_Error (ERR_INAPPLICABLE_CONTINUATION);
  2208.   };
  2209.   goto Pop_Return;
  2210. }
  2211.